COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 TRACE UNTRACE 
C00006 00003	 STEP UNSTEP 
C00009 ENDMK
C⊗;
; TRACE UNTRACE ;
  
   (DF TRACE (%F ;; %X %Y) 
      ; force le bit trace de n'importe quel type de fonction ;
      (SETQ TRACE %F)
      ; TRACE contient la liste des fonctions (cf UNTRACE) ;
      (MAPC %F 
         '(LAMBDA (%F) 
            (IF (MEMQ (TYPEFN %F) '(SUBR FSUBR)) 
               (LESCAPE (STATUS 28 %F)))
            (SETQ %X
                (COND
                   ((SETQ %Y (GET %F EXPR)) EXPR)
                   ((SETQ %Y (GET %F FEXPR)) FEXPR)))
            (PUT %F %Y 'TRACE)
            (PUT %F 
               [LAMBDA
                (CADR %Y)
                (CONS '%PTRAC 
                  (CONS [QUOTE %F] 
                    (IF (LISTP (CADR %Y)) 
                       (CADR %Y)
                       (CONS (CADR %Y)))))]
               %X)))
      %F)
  
   (DE %PTRAC (%F . %L) 
      ;%F = FUNC NAME ;
      (PRINT '-----> %F '/ /  %L)
      ;%L = (VALA1 VALA2 ... VALAN) ;
      (SETQ %X (EPROGN (CDDR (GET %F 'TRACE))))
      (PRINT '<----- %F '/ /  %X))
  
   (DF UNTRACE (%F) 
      ; enleve la TRACE des fonctions contenues dans %F ;
      (OR %F (SETQ %F (AND (BOUNDP 'TRACE) TRACE))
	 (LESCAPE "UNTRACE quoi ?"))
      (MAPC %F
         '(LAMBDA (%F) 
            (IF (MEMQ (TYPEFN %F) '(SUBR FSUBR)) 
               (LESCAPE (STATUS 29 %F)))
            (PUT %F (GET %F 'TRACE) (IF (GET %F EXPR) EXPR FEXPR))
            (REMPROP %F 'TRACE)))
      %F)
  
   (DE %TRTF (%X2 %X1) 
      (MAPC %L '(LAMBDA (%L) (%RPL %X1 %X2 (CDR %L)))))
  
   (DE %RPL (%X %Y %L) 
      (WHILE (LISTP %L) 
         (COND
            ((LISTP (CAR %L)) (%RPL %X %Y (CAR %L)))
            ((EQ (CAR %L) %X) (RPLACA %L %Y)))
         (NEXTL %L)))
  
   (DF TRACEQ (%L) (%TRTF '%TSETQ 'SETQ))
  
   (DF UNTRACQ (%L) (%TRTF 'SETQ '%TSETQ))
  
   (DF TRACEGO (%L) (%TRTF '%TGO 'GO))
  
   (DF UNTRACG (%L) (%TRTF 'GO '%TGO))
  
   (DF %TSETQ (%L) 
      (SET
         (PRIN1 (CAR %L)) 
          (PROGN (PRIN1 '=) (PRINT (EVAL (CADR %L))))))
  
   (DF %TGO (%L) (PRINT (CONS 'ETIQ: %L)) (GOTO (CAR %L)))
; STEP UNSTEP ;

   (DF STEP (%F ;; %X %Y) 
      ; force les bits step de fonctions de type EXPR ou FEXPR ;
      (SETQ STEP %F)
      ; STEP contient la liste des fonctions (cf UNSTEP) ;
      (TEREAD)
      (MAPC %F
         '(LAMBDA (%F) 
            (SETQ %X
                (COND
                   ((SETQ %Y (GET %F EXPR)) EXPR)
                   ((SETQ %Y (GET %F FEXPR)) FEXPR)))
            (PUT %F %Y 'STEP)
            (PUT %F 
               [LAMBDA
                (CADR %Y)
                (CONS '%PSTEP 
                  (CONS [QUOTE %F] 
                    (IF (LISTP (CADR %Y)) 
                       (CADR %Y)
                       (CONS (CADR %Y)))))]
               %X)))
      %F)
  
   (DE %PSTEP (%F . %L) 
      ;%F = FUNC NAME ;
      (PRINT '-----> %F '/ /  %L)
      ;%L = (VALA1 VALA2 ... VALAN) ;
      (STATUS 1 3 8) ; force le bit trace EVAL et STEP ;
      (SETQ %X (EPROGN (CDDR (GET %F 'STEP))))
      (STATUS 2 3 8) ; enleve les bit speciaux ;
      (PRINT '<----- %F '/ /  %X))

   (DF UNSTEP (%F) 
      ; enleve la STEP des fonctions contenues dans %L ;
      (MAPC (OR %F STEP)
         '(LAMBDA (%F) 
            (PUT %F (GET %F 'STEP) (IF (GET %F EXPR) EXPR FEXPR))
            (REMPROP %F 'STEP)))
      %F)